home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE15 / TIPTRIX / XRTFCLIP.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1996-10-14  |  3.1 KB  |  142 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {       xTool - Component Collection                    }
  4. {                                                       }
  5. {  Copyright (c) 1995 Fabula Software, Stefan Bother    }
  6. {    stefc@fabula.com     or    100023,275 on CIS       }
  7. {                                                       }
  8. {*******************************************************}
  9. unit xRtfClipBrd;
  10.   { give access to RTF clipboard format }
  11.  
  12. interface
  13.  
  14. uses
  15.   Windows, Classes, ClipBrd;
  16.  
  17. var
  18.   CF_RTF: Word;   { registered under the Text "Rich Text Format" }
  19.  
  20. type
  21.   TxRTFClipboard = class(TClipboard)
  22.   private
  23.     function GetAsRTF: String;
  24.     procedure SetAsRTF(const Value: String);
  25.   protected
  26.     procedure SetBuffer(Format: Word; var Buffer; Size: Integer);
  27.   public
  28.     property AsRTF: String read GetAsRTF write SetAsRTF;
  29.   end;
  30.  
  31. { converts from and to RTF TStrings, used in TRichEdit for example }
  32. procedure strToRtf(const S: String; aRTF: TStrings);
  33. function  RtfToStr(aRTF: TStrings): String;
  34.  
  35. { use this function for access the new clipboard class }
  36. function RTFClipboard: TxRTFClipboard;
  37.  
  38. implementation
  39.  
  40. uses
  41.   SysUtils;
  42.   
  43. { helper stuff }
  44.  
  45. procedure strToRtf(const S: String; aRTF: TStrings);
  46. var
  47.   aMem : TMemoryStream;
  48. begin
  49.   aMem:=TMemoryStream.Create;
  50.   try
  51.     aMem.Write(Pointer(S)^, Length(S));
  52.     aMem.Position:=0;
  53.     aRtf.LoadFromStream(aMem);
  54.   finally
  55.     aMem.Free;
  56.   end;
  57. end;
  58.  
  59. function RtfToStr(aRTF: TStrings): String;
  60. var
  61.   aMem : TMemoryStream;
  62. begin
  63.   aMem:=TMemoryStream.Create;
  64.   try
  65.     aRTF.SaveToStream(aMem);
  66.     Result:= StrPas(PChar(aMem.Memory));
  67.   finally
  68.     aMem.Free;
  69.   end;
  70. end;
  71.  
  72.  
  73. { TxRTFClipboard }
  74.  
  75. function TxRTFClipboard.GetAsRTF: string;
  76. var
  77.   Data: THandle;
  78. begin
  79.   Open;
  80.   Data := GetClipboardData(CF_RTF);
  81.   try
  82.     if Data <> 0 then
  83.       Result := PChar(GlobalLock(Data)) else
  84.       Result := '';
  85.   finally
  86.     if Data <> 0 then GlobalUnlock(Data);
  87.     Close;
  88.   end;
  89. end;
  90.  
  91. { SetBuffer not protected ???? }
  92. procedure TxRTFClipboard.SetBuffer(Format: Word; var Buffer; Size: Integer);
  93. var
  94.   Data: THandle;
  95.   DataPtr: Pointer;
  96. begin
  97.   Open;
  98.   try
  99.     Data := GlobalAlloc(GMEM_MOVEABLE, Size);
  100.     try
  101.       DataPtr := GlobalLock(Data);
  102.       try
  103.         Move(Buffer, DataPtr^, Size);
  104.       { Adding; not protected why ???? }
  105.         SetClipboardData(Format, Data);
  106.       finally
  107.         GlobalUnlock(Data);
  108.       end;
  109.     except
  110.       GlobalFree(Data);
  111.       raise;
  112.     end;
  113.   finally
  114.     Close;
  115.   end;
  116. end;
  117.  
  118. procedure TxRTFClipboard.SetAsRTF(const Value: string);
  119. begin
  120.   SetBuffer(CF_RTF, PChar(Value)^, Length(Value) + 1);
  121. end;
  122.  
  123. { Initialization of the new cliboard object }
  124.  
  125. var
  126.   FClipboard: TxRTFClipboard;
  127.  
  128. function RTFClipboard: TxRTFClipboard;
  129. begin
  130.   if FClipboard = nil then
  131.      FClipboard := TxRTFClipboard.Create;
  132.   Result := FClipboard;
  133. end;
  134.  
  135. initialization
  136.   FClipboard := nil;
  137.   CF_RTF     := RegisterClipboardFormat('Rich Text Format');
  138. finalization
  139.   FClipboard.Free;
  140. end.
  141.  
  142.